home *** CD-ROM | disk | FTP | other *** search
/ NeXT Education Software Sampler 1992 Fall / NeXT Education Software Sampler 1992 Fall.iso / Programming / Source / winterp-1.13 / src-server / w_timeouts.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-10-04  |  10.9 KB  |  305 lines
  1. /* -*-C-*-
  2. ********************************************************************************
  3. *
  4. * File:         w_timeout.c
  5. * RCS:          $Header: w_timeouts.c,v 1.4 91/03/14 03:14:17 mayer Exp $
  6. * Description:  WINTERP interfaces to XtAppAddTimeOut() and XtRemoveTimeout().
  7. * Author:       Niels Mayer, HPLabs; Bob Leichner, HPLabs
  8. * Created:      Sat Aug 26 07:44:17 1989
  9. * Modified:     Thu Oct  3 21:08:55 1991 (Niels Mayer) mayer@hplnpm
  10. * Language:     C
  11. * Package:      N/A
  12. * Status:       X11r5 contrib tape release
  13. *
  14. * WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  15. * XLISP version 2.1, Copyright (c) 1989, by David Betz.
  16. *
  17. * Permission to use, copy, modify, distribute, and sell this software and its
  18. * documentation for any purpose is hereby granted without fee, provided that
  19. * the above copyright notice appear in all copies and that both that
  20. * copyright notice and this permission notice appear in supporting
  21. * documentation, and that the name of Hewlett-Packard and David Betz not be
  22. * used in advertising or publicity pertaining to distribution of the software
  23. * without specific, written prior permission.  Hewlett-Packard and David Betz
  24. * make no representations about the suitability of this software for any
  25. * purpose. It is provided "as is" without express or implied warranty.
  26. *
  27. * HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS
  28. * SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS,
  29. * IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL,
  30. * INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
  31. * LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
  32. * OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
  33. * PERFORMANCE OF THIS SOFTWARE.
  34. *
  35. * See ./winterp/COPYRIGHT for information on contacting the authors.
  36. * 
  37. * Please send modifications, improvements and bugfixes to mayer@hplabs.hp.com
  38. * Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x
  39. *
  40. ********************************************************************************
  41. */
  42. static char rcs_identity[] = "@(#)$Header: w_timeouts.c,v 1.4 91/03/14 03:14:17 mayer Exp $";
  43.  
  44. #include <stdio.h>
  45. #include <Xm/Xm.h>        /* Xm/Xm.h only needed for "winterp.h"*/
  46. #include "winterp.h"
  47. #include "user_prefs.h"
  48. #include "xlisp/xlisp.h"
  49.  
  50. static LVAL s_TIMEOUT_OBJ=NIL, s_TIMEOUT=NIL;
  51.  
  52.  
  53. /******************************************************************************
  54.  * This is called indirectly via XtAppAddTimeOut() in
  55.  *   Wto_Prim_XtAddTimeOut().
  56.  ******************************************************************************/
  57. static void Winterp_TimeoutProc(client_data, id)
  58.      XtPointer     client_data;
  59.      XtIntervalId* id;
  60. {
  61.   extern LVAL          xlenv, xlfenv;
  62.   LVAL                 oldenv, oldfenv, l_evalforms;
  63.   LVAL                 timeout_obj = (LVAL) client_data;
  64.   LVAL                 c_callback = get_timeout_closure(timeout_obj);
  65.  
  66.   /* the timeout-object is no longer active, so indicate that by nulling the timeout-id */
  67.   set_timeout_id(timeout_obj, NULL);
  68.  
  69.   /* remove <timeout_obj> from v_savedobjs allowing it to be garbage collected */
  70.   {
  71.     extern LVAL v_savedobjs;
  72.     int i = Wso_Hash(timeout_obj);
  73.     LVAL l_hbucket = getelement(v_savedobjs, i);
  74.     LVAL l_prev = NIL;
  75.  
  76.     while (l_hbucket && (car(l_hbucket) != timeout_obj)) {
  77.       l_prev = l_hbucket;
  78.       l_hbucket = cdr(l_hbucket);
  79.     }
  80.     if (!l_hbucket)
  81.       xlerror("Internal error in Winterp_TimeoutProc -- couldn't remove <timeout-obj> from v_savedobjs. Hash error?",
  82.           timeout_obj);
  83.     if (!l_prev)        /* first elt matched */
  84.       setelement(v_savedobjs, i, cdr(l_hbucket));
  85.     else
  86.       rplacd(l_prev, cdr(l_hbucket));
  87.   }
  88.  
  89.   /*
  90.    * Now evaluate code associated with timeout -- 
  91.    * Most of this procedure looks alot like xleval.c:evfun(), which is what
  92.    * the evaluator calls when a functional form is to be evaluated. The
  93.    * main difference is that instead of calling xlabind() to bind the
  94.    * formal parameter symbols of a function to their values in the new
  95.    * lexical environment frame returned by xlframe(getenv(fun)), we just
  96.    * bind the symbol "TIMEOUT_OBJ" to the value of the <timeout-obj> that
  97.    * caused this call.
  98.    */
  99.   
  100.   /* protect some pointers */
  101.   xlstkcheck(3);
  102.   xlsave(oldenv);
  103.   xlsave(oldfenv);
  104.   xlsave(l_evalforms);
  105.  
  106.   /* create a new environment frame */
  107.   oldenv = xlenv;
  108.   oldfenv = xlfenv;
  109.   xlenv = xlframe(getenvt(c_callback));    /* note: changed getenv()-->getenvt() due to name conflict with stdlib.h:getenv() */
  110.   xlfenv = getfenv(c_callback);
  111.  
  112.   /* bind the <timeout-object> to locally referrable lexical var TIMEOUT_OBJ */
  113.   xlpbind(s_TIMEOUT_OBJ, timeout_obj, xlenv);
  114.  
  115.   /* execute the block */
  116.   for (l_evalforms = getbody(c_callback); consp(l_evalforms); 
  117.        l_evalforms = cdr(l_evalforms))
  118.     xleval(car(l_evalforms));
  119.   
  120.   /* restore the environment */
  121.   xlenv = oldenv;
  122.   xlfenv = oldfenv;
  123.   
  124.   /* restore the stack */
  125.   xlpopn(3);
  126. }
  127.  
  128.  
  129. /*****************************************************************************
  130.  * This primitive takes two forms of arguments:
  131.  *      (XT_ADD_TIMEOUT <interval> <code>) or
  132.  *      (XT_ADD_TIMEOUT <interval> <timeout-obj>)
  133.  * returns: <timeout_object>
  134.  *
  135.  * <interval> of the timer in milliseconds.
  136.  *
  137.  * <code> is a list of lisp expressions that are evaluated when the timeout
  138.  * occurs. During the timeout, the lexical environment that existed for
  139.  * the call to Xt_Add_Timeout will be used for value and functional bindings.
  140.  * Additionally, the symbol TIMEOUT_OBJ is bound to the <timeout-obj> that caused
  141.  * the timeout.
  142.  *
  143.  * The form (XT_ADD_TIMEOUT <interval> <timeout-obj>) may be used to more
  144.  * efficiently schedule recurrent timeouts. Instead of creating a new closure
  145.  * around the same <code> each time a recurrent timeout is rescheduled,
  146.  * this second form for XT_ADD_TIMEOUT allows you to take the <timeout-obj>
  147.  * from a previously expired timeout and reschedule a new timeout using the 
  148.  * closure setup by the initial call to (XT_ADD_TIMEOUT <interval> <code>).
  149.  * During the execution of <code>, the symbol TIMEOUT_OBJ is bound to 
  150.  * <timout-obj> so that you don't need to keep around a global variable
  151.  * for each recurrent timeout.
  152.  *
  153.  * The returned <timeout-obj> may be passed into the  functions
  154.  * (XT_REMOVE_TIMEOUT <timeout-obj>), or (XT_ADD_TIMEOUT <interval> <timeout-obj>).
  155.  ****************************************************************************/
  156. LVAL Wto_Prim_XtAddTimeOut()
  157. {
  158.   extern XtAppContext app_context; /* winterp.c */
  159.   extern LVAL s_lambda, xlenv, xlfenv;
  160.   LVAL arg, l_code, timeout_obj=NIL;
  161.   long i;
  162.   unsigned long interval;
  163.   
  164.   /* protect some pointers */
  165.   xlsave1(timeout_obj);
  166.  
  167.   /* get interval */
  168.   if ((i = getfixnum(xlgafixnum())) < 0L)
  169.     xlfail("Timeout interval must be a positive integer.");
  170.   else
  171.     interval = (unsigned long) i;
  172.  
  173.   /* get <code> or <timeout_obj> */
  174.   arg = xlgetarg();
  175.   if (timeoutobj_p(arg)) {
  176.     timeout_obj = arg;
  177.     if (get_timeout_id(timeout_obj) != NULL)
  178.       xlerror("Attempt to schedule a recurrent timeout before previous timeout's expiration.", timeout_obj);
  179.   }
  180.   else if (listp(arg))
  181.     l_code = arg;
  182.   else
  183.     xlerror("Bad Argument Type, expected <timeout-code> or <timeout-object>.", arg);
  184.  
  185.   xllastarg();
  186.  
  187.   /* 
  188.    * create the client_data to be sent to Winterp_TimeoutProc. 
  189.    * That procedure takes the client_data==timeout_obj, extracts the closure,
  190.    * and uses this to execute the timeout callback. We also need to retain
  191.    * the timeout identifier for use in RemoveTimeout. For simplicity, we save
  192.    * in lisp object timeout_obj.
  193.    */
  194.  
  195.   /* if args gave <code>, need to create timeout-obj and closure around <code> */
  196.   if (!timeout_obj) {        
  197.     timeout_obj = new_timeoutobj();
  198.     set_timeout_closure(timeout_obj,
  199.             xlclose(s_TIMEOUT, s_lambda, NIL, l_code, xlenv, xlfenv));
  200.   }
  201.  
  202.   set_timeout_id(timeout_obj,
  203.          XtAppAddTimeOut(app_context, interval, Winterp_TimeoutProc, (XtPointer) timeout_obj));  
  204.  
  205.   /*
  206.    * Put timeout_obj in savedobjs so that it gets marked during gc. In that way, we
  207.    * know that the timeout closure (i.e. the callback code, and it's lexical
  208.    * environment) and timeout identifier won't get garbage collected while the
  209.    * timeout-object is "referenced" inside Motif. The timeout_obj gets removed from
  210.    * savedobjs each time the timeout expires, or when xt_remove_timeout gets called.
  211.    */
  212.   { 
  213.     int  i = Wso_Hash(timeout_obj);
  214.     LVAL l_hbucket;
  215.     extern LVAL v_savedobjs;
  216.     
  217.     xlsave1(l_hbucket);
  218.     l_hbucket = cons(timeout_obj, getelement(v_savedobjs, i));
  219.     setelement(v_savedobjs, i, l_hbucket);
  220.     xlpop();
  221.   }
  222.  
  223.   /* resore the stack */
  224.   xlpop();
  225.  
  226.   return (timeout_obj);
  227. }
  228.  
  229.  
  230. /******************************************************************************
  231.  * extern void XtRemoveTimeout();
  232.  *      XtIntervalId timer;      
  233.  * 
  234.  * Lisp:   (xt_remove_timeout <timeout_obj>)
  235.  *         where <timeout_obj> is the value returned by xt_add_timeout.
  236.  ******************************************************************************/
  237. LVAL Wto_Prim_XtRemoveTimeout()
  238. {
  239.   extern LVAL true;
  240.   LVAL timeout_obj;
  241.   
  242.   timeout_obj = xlga_timeoutobj();
  243.   xllastarg();
  244.  
  245.   if (get_timeout_id(timeout_obj) == NULL)
  246.     xlerror("Attempt to remove an expired/removed timeout.", timeout_obj);
  247.   
  248.   XtRemoveTimeOut(get_timeout_id(timeout_obj));
  249.  
  250.   /* the timeout-object is no longer active, so indicate that by nulling the timeout-id */
  251.   set_timeout_id(timeout_obj, NULL);
  252.  
  253.   /* remove <timeout_obj> from v_savedobjs allowing it to be garbage collected */
  254.   {
  255.     extern LVAL v_savedobjs;
  256.     int i = Wso_Hash(timeout_obj);
  257.     LVAL l_hbucket = getelement(v_savedobjs, i);
  258.     LVAL l_prev = NIL;
  259.  
  260.     while (l_hbucket && (car(l_hbucket) != timeout_obj)) {
  261.       l_prev = l_hbucket;
  262.       l_hbucket = cdr(l_hbucket);
  263.     }
  264.     if (!l_hbucket)
  265.       xlerror("Internal error in Wto_Prim_XtRemoveTimeout -- couldn't remove <timeout-obj> from v_savedobjs. Hash error?",
  266.           timeout_obj);
  267.     if (!l_prev)        /* first elt matched */
  268.       setelement(v_savedobjs, i, cdr(l_hbucket));
  269.     else
  270.       rplacd(l_prev, cdr(l_hbucket));
  271.   }
  272.  
  273.   return (true);
  274. }
  275.  
  276.  
  277. /******************************************************************************
  278.  * (TIMEOUT_ACTIVE_P <timeout_obj>)
  279.  *     --> returns T if <timeout_obj> is still scheduled, returns
  280.  *        NIL if <timeout_obj> has expired or if the timeout was
  281.  *        inactivated by XT_REMOVE_TIMEOUT.
  282.  *
  283.  *  <timeout_obj> is the value returned by XT_ADD_TIMEOUT.
  284.  ******************************************************************************/
  285. LVAL Wto_Prim_TIMEOUT_ACTIVE_P()
  286. {
  287.   extern LVAL true;
  288.   LVAL timeout_obj;
  289.   
  290.   timeout_obj = xlga_timeoutobj();
  291.   xllastarg();
  292.   
  293.   return (get_timeout_id(timeout_obj) ? true : NIL);
  294. }
  295.  
  296.  
  297. /******************************************************************************
  298.  *
  299.  ******************************************************************************/
  300. Wto_Init()
  301. {
  302.   s_TIMEOUT_OBJ = xlenter("TIMEOUT_OBJ");
  303.   s_TIMEOUT     = xlenter("XT_TIMEOUT");
  304. }
  305.